home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swags_z.zip / SCREEN.SWG / 0081_Multipurpose Screen Unit.pas < prev    next >
Pascal/Delphi Source File  |  1995-02-28  |  11KB  |  411 lines
  1. unit screenio;
  2.  
  3. interface
  4.  
  5. uses crt,dos;
  6.  
  7. const
  8.   SHFTR   = 1;
  9.   SHFTL   = 2;
  10.   CTRL    = 4;
  11.   ALT     = 8;
  12.   SCRL    = 16;
  13.   NUML    = 32;
  14.   CAPL    = 64;
  15.   INS     = 128;
  16.   _BKSPC  = 8;
  17.   _ESC    = 27;
  18.   _UP     = 328;
  19.   _DN     = 336;
  20.   _RIGHT  = 333;
  21.   _LEFT   = 331;
  22.   _PGUP   = 329;
  23.   _PGDN   = 337;
  24.   _HOME   = 327;
  25.   _END    = 335;
  26.   _DEL    = 339;
  27.   _INS    = 338;
  28.   _F1     = 315;
  29.   _F2     = 316;
  30.   _F3     = 317;
  31.   _F4     = 318;
  32.   _F5     = 319;
  33.   _F6     = 320;
  34.   _F7     = 321;
  35.   _F8     = 322;
  36.   _F9     = 323;
  37.   _F10    = 324;
  38.   single  = '┌─┐│└┘';
  39.   double  = '╔═╗║╚╝';
  40.   bellsnd = 50;
  41.  
  42. type
  43.   ScreenType = array[1..25,1..80] of word;
  44.   str2  = string[2];
  45.   str10 = string[10];
  46.   str20 = string[20];
  47.   str80 = string[80];
  48.  
  49. procedure InitScrn;
  50. function  CenterNum(Num : longint;Len : byte) : string;
  51. function  FileOpen(var Fn      : text;
  52.                       FileName: String): Boolean;
  53. function  FileVOpen(var Fn      : file;
  54.                       FileName: String): Boolean;
  55. function  Get_Key : Integer;
  56. function  GetKeyScan(SCANBYTE : BYTE) : Boolean;
  57. PROCEDURE GetText(Left,Top,Right,Bottom:INTEGER;VAR dest);
  58. PROCEDURE PutText(Left,Top,Right,Bottom:INTEGER;VAR Source);
  59. procedure GetChar(X,Y           : integer;           { Display Coord }
  60.                   var Character : char;              { the character }
  61.                   var COLOR     : integer);          { its Attribute }
  62. procedure Scroll(  Direction : Char;   { Direction U=Up D=Down }
  63.                    Number,             { Number of lines to be scrolled }
  64.                    COLOR,              { Attribute for the blank lines created }
  65.                    XLeft,              { Column in the upper left corner }
  66.                    YLeft,              { line in the upper left corner }
  67.                    XRight,             { Column in the lower right corner }
  68.                    YRight     : integer);  { Line in lower right corner }
  69. procedure WriteXY(X,Y : Byte;Str : String);
  70. procedure DrawBox(Title,BoxDef : string;TopX,TopY,BotX,BotY,Shadow,Border,WindC : byte);
  71. function  Parse(ParseChr : char;VAR Str : string) : string;
  72. function  SelMenu(Xpos,Ypos,NormColor,HighColor,BordColor,Box : Byte;
  73.                  MenuName,MenuS : string) : Char;
  74. function  Trim_Str(InputStr : string) : string;
  75. procedure soundbell;
  76. procedure InValidInput(Prompt : string);
  77. procedure ClearInvalid;
  78.  
  79. var
  80.   ErrPrompt : Boolean;
  81.  
  82. implementation
  83.  
  84. var
  85.   Screen : ^ScreenType;
  86.   vinput : array[1..240] of word;
  87.  
  88. procedure soundbell;
  89.   begin
  90.     sound(500);
  91.     delay(bellsnd);
  92.     nosound;
  93.   end;
  94.  
  95. procedure InValidInput(Prompt : string);
  96.   var
  97.     xpos,oldx,oldy,attr : byte;
  98.   begin
  99.     GetText(1,1,80,3,vinput);
  100.     attr := textattr;
  101.     oldx := wherex;
  102.     oldy := wherey;
  103.     textattr := $5f;
  104.     xpos := 80-3-length(prompt);
  105.     DrawBox('',Single,xpos,1,80,3,$00,$5f,$5f);
  106.     gotoxy(xpos+2,2);
  107.     write(prompt);
  108.     textattr := attr;
  109.     gotoxy(oldx,oldy);
  110.     ErrPrompt := True;
  111.   end;
  112.  
  113. procedure ClearInvalid;
  114.   begin
  115.     ErrPrompt := False;
  116.     PutText(1,1,80,3,vinput);
  117.   end;
  118.  
  119. procedure InitScrn;
  120.   begin
  121.     IF LastMode = Mono THEN Screen := Ptr($b000,0)
  122.       ELSE Screen:=Ptr($b800,0);
  123.   end;
  124.  
  125. function Trim_Str(InputStr : string) : string;
  126.   var
  127.     count  : byte;
  128.   begin
  129.     count := 1;
  130.     while InputStr[count] = ' ' do
  131.       begin
  132.         Delete(InputStr,1,1);
  133.         inc(count);
  134.       end;
  135.     count := Length(InputStr);
  136.     while InputStr[count] = ' ' do
  137.       begin
  138.         Delete(InputStr,Length(InputStr),1);
  139.         dec(count);
  140.       end;
  141.     Trim_Str := InputStr;
  142.   end;
  143.  
  144. function CenterNum(Num : longint;Len : byte) : string;
  145.   var
  146.     Tstr : string;
  147.     SLen,TVal : byte;
  148.   begin
  149.     Str(Num,Tstr);
  150.     SLen := Length(Tstr);
  151.     if SLen < Len then
  152.       repeat
  153.         Insert(' ',Tstr,Slen+1);
  154.         inc(Slen);
  155.         if SLen < Len then Insert(' ',Tstr,1);
  156.         inc(Slen);
  157.       until Slen >= Len else if Slen > Len then Delete(Tstr,Len+1,Slen-Len);
  158.     Centernum := Tstr;
  159.   end;
  160.  
  161. function FileVOpen(var Fn      : file;
  162.                       FileName: String): Boolean;
  163. { Boolean function that returns True if the file exists;otherwise,
  164.  it returns False. Closes the file if it exists. }
  165. begin
  166.  {$I-}
  167.  Assign(Fn, FileName);
  168.  
  169.  FileMode := 2;  { Set file access to read/write }
  170.  Reset(Fn);
  171.  {$I+}
  172.  FileVOpen := (IOResult = 0) and (FileName <> '');
  173. end;  { FileExists }
  174.  
  175. function FileOpen(var Fn      : text;
  176.                       FileName: String): Boolean;
  177. { Boolean function that returns True if the file exists;otherwise,
  178.  it returns False. Closes the file if it exists. }
  179. begin
  180.  {$I-}
  181.  Assign(Fn, FileName);
  182.  
  183.  FileMode := 2;  { Set file access to read/write }
  184.  Reset(Fn);
  185.  {$I+}
  186.  FileOpen := (IOResult = 0) and (FileName <> '');
  187. end;  { FileExists }
  188.  
  189. function Get_Key : Integer;
  190.   Var CH : Char;
  191.       Int : Integer;
  192.   begin
  193.     CH := ReadKey;
  194.     If CH = #0 then
  195.       begin
  196.         CH := ReadKey;
  197.         int := Ord(CH);
  198.         inc(int,256);
  199.       end else Int := Ord(CH);
  200.     Get_Key := Int;
  201.   end;
  202.  
  203. function GetKeyScan(SCANBYTE : BYTE) : Boolean;
  204.   var
  205.     Regs : Registers;
  206.   begin
  207.     Regs.ah := $2;
  208.     intr($16,Regs);
  209.     if (Regs.al and SCANBYTE <> 0) then GetKeyScan := true
  210.       else GetKeyScan := False;
  211.   end;
  212.  
  213. PROCEDURE GetText(Left,Top,Right,Bottom:INTEGER;VAR dest);
  214.   TYPE
  215.     DestType = ARRAY[1..2000] OF WORD;
  216.   VAR
  217.     d      : 1..2000;
  218.     x      : 1..80;
  219.     y      : 1..25;
  220.   BEGIN
  221.     d := 1;
  222.     FOR y:=Top TO Bottom DO
  223.       FOR x:= Left TO Right DO
  224.         BEGIN
  225.           DestType(Dest)[d] := Screen^[y,x];
  226.           inc(d);
  227.         END
  228.   END;
  229.  
  230. PROCEDURE PutText(Left,Top,Right,Bottom:INTEGER;VAR Source);
  231.   TYPE
  232.     SourceType = ARRAY[1..2000] OF WORD;
  233.   VAR
  234.     x      : 1..80;
  235.     y      : 1..25;
  236.     s      : 1..2000;
  237.   BEGIN
  238.     s := 1;
  239.     FOR y := Top TO Bottom DO
  240.       FOR x := Left TO Right DO
  241.         BEGIN
  242.           Screen^[y,x] := SourceType(Source)[s];
  243.           inc(s);
  244.         END
  245.   END;
  246.  
  247. procedure GetChar(X,Y           : integer;           { Display Coord }
  248.                   var Character : char;              { the character }
  249.                   var COLOR     : integer);          { its Attribute }
  250.   var
  251.     Regs : Registers;           { Register-Variable for the Interrupt }
  252.  
  253. begin
  254.   gotoxy(X,Y);                  { cursor on the position indicated }
  255.   Regs.ah := 8;                 { Get Function number for char. and Attribute }
  256.   Regs.bh := 0;                 { display page }
  257.   Intr($10,Regs);               { Invoke DOS registers }
  258.   Character := chr(Regs.al);    { ASCII-Code of character }
  259.   COLOR := Regs.ah;             { Attribute of the character }
  260. end;
  261.  
  262. procedure Scroll(  Direction : Char;   { Direction U=Up D=Down }
  263.                    Number,             { Number of lines to be scrolled }
  264.                    COLOR,              { Attribute for the blank lines created }
  265.                    XLeft,              { Column in the upper left corner }
  266.                    YLeft,              { line in the upper left corner }
  267.                    XRight,             { Column in the lower right corner }
  268.                    YRight     : integer);  { Line in lower right corner }
  269.  
  270. var Regs : Registers;       { Register variable for calling Interrupt }
  271.  
  272. begin
  273.   if Direction = 'U' then
  274.     Regs.ah := 6                        { Scroll Up }
  275.   else Regs.ah := 7;                    { Scroll Down }
  276.   Regs.al := Number;
  277.   Regs.bh := COLOR;                     { Color of empty line(s) }
  278.   Regs.ch := YLeft-1;                   { Upper left }
  279.   Regs.cl := XLeft-1;                   { coordinates }
  280.   Regs.dh := YRight-1;                  { Lower right }
  281.   Regs.dl := XRight-1;                  { coordinates }
  282.   Intr($10,Regs);                       { Call BIOS-Video-Interrupt }
  283. end;
  284.  
  285. procedure WriteXY(X,Y : Byte;Str : String);
  286.   begin
  287.     GotoXY(X,Y);
  288.     Write(Str);
  289.   end;
  290.  
  291. procedure DrawBox(Title,BoxDef : string;TopX,TopY,BotX,BotY,Shadow,Border,WindC : byte);
  292.   var
  293.     count,space,
  294.     TX,TY,BX,BY,OldC : byte;
  295.   begin
  296.     OldC := Textattr;
  297.     TX := Lo(WindMin);
  298.     TY := Hi(WindMin);
  299.     BX := Lo(WindMax);
  300.     BY := Hi(WindMax);
  301.     if Shadow > 0 then
  302.       begin
  303.         TextAttr := Shadow;
  304.         Window(TopX+2,TopY+1,BotX+2,BotY+1);
  305.         clrscr;
  306.       end;
  307.     TextAttr := WindC;
  308.     Window(TopX,TopY,BotX,BotY);
  309.     if windC <> $00 then clrscr;
  310.     Window(TX+1,TY+1,BX+1,BY+1);
  311.     TextAttr := Border;
  312.  
  313.     WriteXY(TopX,TopY,BoxDef[1]);
  314.     for count := 1 to BotX-TopX-1 do
  315.       write(BoxDef[2]);
  316.     write(BoxDef[3]);
  317.  
  318.     For count := TopY+1 to BotY-1 do
  319.       begin
  320.         WriteXY(TopX,Count,BoxDef[4]);
  321.         WriteXY(BotX,Count,BoxDef[4]);
  322.       end;
  323.  
  324.     WriteXY(TopX,BotY,BoxDef[5]);
  325.     for count := 1 to BotX-TopX-1 do
  326.       write(BoxDef[2]);
  327.     write(BoxDef[6]);
  328.  
  329.     If Length(Title)+2 < (BotX-TopX-2) then
  330.       begin
  331.         GotoXY(TopX+ (Round((BotX-TopX)/2) - Round((Length(Title)/2)+1)) ,TopY);
  332.         if Title <> '' then write(' ',Title,' ');
  333.       end;
  334.  
  335.     TextAttr := OldC;
  336.   end;
  337.  
  338. function Parse(ParseChr : char;VAR Str : string) : string;
  339.   var
  340.     count : byte;
  341.   begin
  342.     count := Pos(ParseChr,Str);
  343.     if count > 0 then
  344.       begin
  345.         Parse := Copy(Str,1,count-1);
  346.         Str   := Copy(Str,count+1,Length(Str)-count);
  347.       end else Parse := '';
  348.   end;
  349.  
  350. function SelMenu(Xpos,Ypos,NormColor,HighColor,BordColor,Box : Byte;
  351.                  MenuName,MenuS : string) : Char;
  352.   type
  353.     MenuRec = record
  354.       mstr  : string[12];
  355.       xpos : byte;
  356.     end;
  357.   var
  358.     Selection : integer;
  359.     x,lastm,lastx,
  360.     y,Xlen    : byte;
  361.     MenuArr   : array[1..20] of MenuRec;
  362.     CH        : Char;
  363.   begin
  364.     lastm := 0;
  365.     lastX := xpos;
  366.     Repeat
  367.       inc(LastM);
  368.       MenuArr[LastM].mstr := ' '+Parse('|',MenuS)+' ';
  369.       MenuArr[LastM].xpos := LastX;
  370.       LastX := Length(MenuArr[LastM].mstr)+LastX;
  371.     until MenuS = '';
  372.     x := Length(MenuArr[LastM].mstr)+MenuArr[LastM].xpos;
  373.     if Box = 1 then DrawBox(MenuName,single,Xpos-1,Ypos-1,x,Ypos+1,0,BordColor,NormColor);
  374.     Gotoxy(Xpos,Ypos);
  375.     for x := 1 to lastM do
  376.       Write(MenuArr[x].mstr);
  377.     x := 1;
  378.     repeat
  379.       case selection of
  380.         333 : inc(x);
  381.         331 : dec(x);
  382.       end;
  383.       if x = lastm+1 then x := 1;
  384.       if x = 0 then x := lastm;
  385.       textattr := HighColor;
  386.       WriteXY(MenuArr[x].xpos,Ypos,MenuArr[x].mstr);
  387.       gotoxy(menuArr[x].xpos+1,Ypos);
  388.       selection := Get_Key;
  389.       gotoxy(menuArr[x].xpos+1,Ypos);
  390.       textattr := NormColor;
  391.       WriteXY(MenuArr[x].xpos,Ypos,MenuArr[x].mstr);
  392.     until (selection > 333) or (selection < 331);
  393.     if selection = 13 then
  394.       begin
  395.         y := 2;
  396.         while y < Length(MenuArr[x].mstr)-1 do
  397.           begin
  398.             Ch := MenuArr[x].mstr[y];
  399.             If (CH >= 'A') and (CH <= 'Z') then SelMenu := CH;
  400.             inc(y);
  401.           end;
  402.       end else SelMenu := Chr(Selection);
  403.   end;
  404.  
  405. var
  406.   keyval : integer;
  407.  
  408. begin
  409.   ErrPrompt := False;
  410.   InitScrn;
  411. end.